home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / triang.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  2KB  |  73 lines
  1. ;; TRIANGLE sequential version
  2.  
  3. (defmodule triang
  4.  
  5. (standard0)
  6.  
  7. ()
  8.  
  9. (deflocal answer ())
  10. (deflocal final ())
  11.  
  12. (deflocal board  (make-vector 16 1)) 
  13. (deflocal sequence (make-vector 14 0))
  14. (deflocal a (make-initialized-vector 
  15.          1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4 7 
  16.          11 8 12 13 6 10 15 9 14 13 13 14 15 9 10 6 6))
  17. (deflocal b (make-initialized-vector 
  18.          2 4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 2 
  19.          4 7 5 8 9 3 6 10 5 9 8 12 13 14 8 9 5 5))
  20. (deflocal c (make-initialized-vector
  21.          4 7 11 8 12 13 6 10 15 9 14 13 13 14 15 9 
  22.          10 6 1 2 4 3 5 6 1 3 6 2 5 4 11 12 13 7 8 4 4))
  23. ((setter vector-ref) board 5 0)
  24.  
  25. (defun last-position ()
  26.   (labels ((last-aux (i)
  27.            (cond ((= i (vector-length board))
  28.               0)
  29.              ((= 1 (vector-ref board i))
  30.               i)
  31.              (t (last-aux (+ i 1))))))
  32.      (last-aux 1)))
  33.  
  34. (defun try (i depth)     
  35.   (cond ((= depth 14)
  36.      (let ((lp (last-position)) )
  37.        (unless (memq lp final) 
  38.            (setq final (cons lp final))))
  39.      (setq answer (cons (cdr (convert-vector-list sequence)) answer))
  40.      (format t "Answer: ~a~%" (car answer))
  41.      t)
  42.         ((and (= 1 (vector-ref board (vector-ref a i)))
  43.               (= 1 (vector-ref board (vector-ref b i)))
  44.               (= 0 (vector-ref board (vector-ref c i))))
  45.      ((setter vector-ref) board (vector-ref a i) 0)
  46.      ((setter vector-ref) board (vector-ref b i) 0)
  47.      ((setter vector-ref) board (vector-ref c i) 1)
  48.      ((setter vector-ref) sequence depth i)
  49.      (labels ((iterate (j depth) ;; ((j 0 (+ j 1)) (depth (+ depth 1) depth))
  50.                (if (or (= j 36) (try j depth))
  51.                    ()
  52.                  (iterate (+ j 1) depth))))
  53.          (iterate 0 (+ depth 1)))
  54.      ((setter vector-ref) board (vector-ref a i) 1)
  55.      ((setter vector-ref) board (vector-ref b i) 1)
  56.      ((setter vector-ref) board (vector-ref c i) 0)
  57.      nil)
  58.     (t nil)))
  59.  
  60.  
  61. (defun gogogo (i)
  62.   (try i 1))
  63.  
  64. (defun testtriang ()
  65.   (cpu-time)
  66.   (gogogo 22)
  67.   (print (cpu-time)))
  68.  
  69. (export try gogogo testtriang)
  70.  
  71.  
  72. )
  73.